home *** CD-ROM | disk | FTP | other *** search
/ The 640 MEG Shareware Studio 2 / The 640 Meg Shareware Studio CD-ROM Volume II (Data Express)(1993).ISO / comm / brc_asp1.zip / ZIPDIR.PAS < prev    next >
Pascal/Delphi Source File  |  1992-01-29  |  4KB  |  120 lines
  1.  
  2. (*  Atkinson - Home Computer - 414-543-8929 - ZIP-KIT *)
  3.  
  4. {$a+,b-,d+,e-,f-,i-,l+,n-,o-,r-,s-,v-}
  5. {$m 16384,100000,100000}
  6.  
  7. unit zipdir;
  8.  
  9. interface
  10.  
  11. uses dos, strings;
  12.  
  13. procedure ZipDirSetup (var ZipFileName : string; var ZipDirStatus: integer);
  14. procedure ZipDirFetch (var ZipDirItem  : string; var ZipDirStatus: integer);
  15.  
  16. implementation
  17.  
  18. type
  19.    buftype = array [0..20480] of byte;
  20.    local_header = record
  21.      case a_signature : longint of
  22.        $04034b50  :  ( a_extract_version_reqd    :  word;
  23.                        a_bit_flag                :  word;
  24.                        a_compress_method         :  word;
  25.                        a_last_mod_time           :  word;
  26.                        a_last_mod_date           :  word;
  27.                        a_crc32                   :  longint;
  28.                        a_compressed_size         :  longint;
  29.                        a_uncompressed_size       :  longint;
  30.                        a_filename_length         :  word;
  31.                        a_extra_field_length      :  word);
  32.  
  33.        $04034b50  :  ( dum1                      :  array[0..2] of word;
  34.                        dum_date                  :  longint);
  35.    end;
  36.  
  37. var
  38.    f1        : file;
  39.    result    : word;
  40.    work1     : local_header;
  41.    buffer    : buftype;
  42.    loop1     : integer;
  43.    loop2     : integer;
  44.    size      : integer;
  45.    remainder : integer;
  46.    zipfile   : string;
  47.    zipdate   : dos.datetime;
  48.    uncmp_tot : longint;
  49.  
  50. procedure ZipDirSetup (var ZipFileName : string; var ZipDirStatus: integer);
  51.  
  52. begin
  53.    uncmp_tot := 0;
  54.    zipfile := ZipFileName;
  55.    if (zipfile = '') or
  56.      ((0 = pos('.ZIP',zipfile)) and
  57.       (0 = pos('.zip',zipfile)))
  58.        then begin
  59.             ZipDirStatus := 98;
  60.             exit;
  61.             end;
  62.  
  63.    assign(f1,zipfile);
  64.    {$I-}  reset(f1,1);  {$I+}
  65.    ZipDirStatus := ioresult;
  66.    if 0 = ioresult
  67.       then blockread(f1,work1,30,result);
  68. end;
  69.  
  70. procedure ZipDirFetch (var ZipDirItem  : string; var ZipDirStatus: integer);
  71. begin
  72.    if work1.a_signature = $02014b50
  73.       then begin
  74.            ZipDirItem := '';
  75.            ZipDirStatus := 99;
  76.            close(f1);
  77.            exit;
  78.            end;
  79.    ZipDirItem := '';
  80.    size := work1.a_compressed_size div 20480;
  81.    remainder := work1.a_compressed_size mod 20480;
  82.    uncmp_tot := uncmp_tot + work1.a_uncompressed_size;
  83.    blockread (f1,buffer,work1.a_filename_length+work1.a_extra_field_length,
  84.               result);
  85.    ZipDirItem := ZipDirItem + ZStr (work1.a_compressed_size,7)
  86.                             + ZStr (work1.a_uncompressed_size,7);
  87.    case lo (work1.a_compress_method) of
  88.          0 : ZipDirItem := ZipDirItem + ' stored   ';
  89.          1 : ZipDirItem := ZipDirItem + ' shrunk   ';
  90.       2..5 : ZipDirItem := ZipDirItem + ' reduce  '
  91.                    + ZStr (lo(work1.a_compress_method)-1,1);
  92.          6 : ZipDirItem := ZipDirItem + ' imploded ';
  93.          8 : ZipDirItem := ZipDirItem + ' A-Xtra   ';
  94.        else
  95.              ZipDirItem := ZipDirItem + ' unknown  ';
  96.        end;
  97.    if work1.a_uncompressed_size < 1 then work1.a_uncompressed_size := 1;
  98.    ZipDirItem := ZipDirItem + ZStr (trunc((work1.a_compressed_size /
  99.           work1.a_uncompressed_size -1) * -100 + 5e-1),2) + '%';
  100.    unpacktime (work1.dum_date,zipdate);
  101.    ZipDirItem := ZipDirItem + ' '
  102.                + FStr (zipdate.month,2) + '-'
  103.                + FStr (zipdate.day,2)   + '-'
  104.                + FStr (zipdate.year,4)  + ' '
  105.                + FStr (zipdate.hour,2)  + ':'
  106.                + FStr (zipdate.min,2)   + ':'
  107.                + FStr (zipdate.sec,2)   + ' ';
  108.    for loop1 := 0 to work1.a_filename_length-1 do
  109.        ZipDirItem := ZipDirItem + (char (buffer [loop1]));
  110.    if size > 0
  111.       then begin
  112.            for loop1 := 1 to size do
  113.              blockread (f1,buffer,20480,result);
  114.            end;
  115.    if remainder > 0
  116.       then blockread (f1,buffer,remainder,result);
  117.    blockread (f1,work1,30,result);
  118. end;
  119.  
  120. end.